home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1999 March - Disc 1 / Macworld (1999-03) (Disk 1).dmg / Shareware World / Utilities / Text Processing / Alpha / Tcl / SystemCode / stringsLists.tcl < prev    next >
Encoding:
Text File  |  1998-12-16  |  15.6 KB  |  553 lines  |  [TEXT/ALFA]
  1. #
  2. # strings.tcl (Mark Nagata and Tom Scavo and Vince Darley)
  3. #
  4.  
  5. namespace eval quote {}
  6. namespace eval text {}
  7. ## 
  8.  # -------------------------------------------------------------------------
  9.  # 
  10.  # "quote::" --
  11.  # 
  12.  # Manipulate string so search and insertion procedures work as expected.
  13.  # These files have been both renamed and rewritten from the former
  14.  # 'quoteExpr' procs.  They fix a number of bugs, and make their purpose
  15.  # clear.  There were numerous examples throughout Alpha's Tcl code which
  16.  # used the wrong quote function under the old scheme.
  17.  # 
  18.  # quote::Find
  19.  # 
  20.  #     use this for 'glob' type searches.
  21.  #     
  22.  # quote::Regfind
  23.  # 
  24.  #  use this for regexp searches
  25.  #  
  26.  # quote::Insert
  27.  # 
  28.  #  Quotes any block of text captured from a window so it can be used as a 
  29.  #  Tcl string. e.g. 'set a [quote::Insert [getSelect]] ; eval insertText $a'
  30.  #  will work correctly.  Can be used to generate procedures on the fly,
  31.  #  especially to add to your prefs.tcl:
  32.  #   set a [quote::Insert [getSelect]]
  33.  #   addUserLine "proc foo \{\} \{ return \"$a\" \}"
  34.  # 
  35.  # quote::Regsub
  36.  # 
  37.  #  use this for the replacement expression.  A common usage might look
  38.  #  like this:
  39.  #   
  40.  #   regsub -all [quote::Regfind $from] [read $cid] [quote::Regsub $to] out
  41.  # -------------------------------------------------------------------------
  42.  ##
  43. proc quote::Find  str {
  44.     regsub -all {[][\|*+()]} $str {\\&} str
  45.     return $str
  46. }
  47.  
  48. proc quote::Regfind str {
  49.     regsub -all {[][\$?^|*+()\.\{\}]} $str {\\&} str
  50.     return $str
  51. }
  52.  
  53. proc quote::Insert str {
  54.     regsub -all {[][\$"\{\}]} $str {\\&} str
  55.     regsub -all "\[\r\n\]" $str "\\r" str
  56.     regsub -all "\t" $str "\\t" str
  57.     return $str
  58. }
  59.  
  60. proc quote::Display str {
  61.     regsub -all "\r" $str "\\r" str
  62.     regsub -all "\n" $str "\\n" str
  63.     regsub -all "\t" $str "\\t" str
  64.     return $str
  65. }
  66.  
  67. proc quote::Undisplay str {
  68.     regsub -all {\\r} $str "\r" str
  69.     regsub -all {\\n} $str "\n" str
  70.     regsub -all {\\t} $str "\t" str
  71.     return $str
  72. }
  73.  
  74. proc quote::Regsub str {
  75.     regsub -all {(\\|&)} $str {\\&} str
  76.     return $str
  77. }
  78.  
  79. ## 
  80.  # -------------------------------------------------------------------------
  81.  # 
  82.  # "quote::Prettify" --
  83.  # 
  84.  #  Since we're supposed to be a LaTeX editor, we handle symbols with
  85.  #  TeX in a bit differently
  86.  # -------------------------------------------------------------------------
  87.  ##
  88. proc quote::Prettify str {
  89.     set a [string toupper [string index $str 0]]
  90.     regsub -all {([^A-Z])([A-Z])} [string range $str 1 end] {\1 \2} b
  91.     regsub -all {((La|Bib|Oz) )?Te X} $a$b {\2TeX } a
  92.     regsub -all {::} $a {-} a
  93.     return $a
  94. }
  95. proc quote::Menuify str {
  96.     set a [string toupper [string index $str 0]]
  97.     regsub -all {([^A-Z])([A-Z])} [string range $str 1 end] {\1 \2} b
  98.     append a $b
  99. }
  100. ## 
  101.  # -------------------------------------------------------------------------
  102.  # 
  103.  # "quote::WhitespaceReg" --
  104.  # 
  105.  #  Quote a string so you can search for it ignoring all problems with
  106.  #  whitespace: all sequences of space/tab/cr are treated alike.
  107.  # -------------------------------------------------------------------------
  108.  ##
  109. proc quote::WhitespaceReg { str } { 
  110.     regsub -all "\[ \t\r\n\]+" $str {[ \t\r\n]+} str
  111.     return $str
  112. }
  113.  
  114. ## 
  115.  # -------------------------------------------------------------------------
  116.  # 
  117.  # "lremove" --
  118.  # 
  119.  #  removes items from a list
  120.  #  
  121.  #  options are '-all' to remove all, and -glob, -exact or -regexp
  122.  #  for search type.  '-exact' is the default. '--' terminates options.
  123.  #  
  124.  #  lremove ?-opts? l args
  125.  #  
  126.  #  Note: if you want to remove all items of list 'b' from list 'a',
  127.  #  the following is incorrect: lremove $a $b, you must use
  128.  #  'eval lremove [list $a] $b', so that b is expanded.
  129.  #  
  130.  #  There is now a new option -l which treats the extra args as lists,
  131.  #  so you can do lremove -l $a $b if you want.
  132.  # -------------------------------------------------------------------------
  133.  ##
  134. proc lremove {args} {
  135.     set opts(-all) 0
  136.     set type "-exact"
  137.     getOpts
  138.     set l [lindex $args 0]
  139.     if {[info exists opts(-glob)]} { set type "-glob" }
  140.     if {[info exists opts(-regexp)]} { set type "-regexp" }
  141.     if {[info exists opts(-l)]} { 
  142.     set args [join [lreplace $args 0 0] " "]
  143.     } else {
  144.     set args [lreplace $args 0 0]
  145.     }
  146.     foreach i $args {
  147.     if {[set ix [lsearch $type $l $i]] == -1} continue
  148.     set l [lreplace $l $ix $ix]
  149.     if {$opts(-all)} {
  150.         while {[set ix [lsearch $type $l $i]] != -1} {
  151.         set l [lreplace $l $ix $ix]
  152.         }
  153.     }
  154.     }
  155.     return $l
  156. }
  157.  
  158. ## 
  159.  # -------------------------------------------------------------------------
  160.  # 
  161.  # "getOpts" --
  162.  # 
  163.  #  Rudimentary option passing.  Uses upvar to get to the 'args' list of
  164.  #  the calling procedure and scans that.  Option information is stored
  165.  #  in the 'opts' array of the calling procedure.
  166.  #  
  167.  #  Options are assumed to be flags, unless they occur in the optional
  168.  #  parameter list.  Then they are variables which take a value; the
  169.  #  next item in the args list.  If an item is a pair, then the first
  170.  #  is the var name and the second the number of arguments to give it.
  171.  # -------------------------------------------------------------------------
  172.  ##
  173. proc getOpts {{take_value ""} {set "set"}} {
  174.     upvar args a
  175.     upvar opts o
  176.     while {[string match \-* [set arg [lindex $a 0]]]} {
  177.     set a [lreplace $a 0 0]
  178.     if {$arg == "--"} {
  179.         return
  180.     } else {
  181.         if {[set idx [lsearch -regexp $take_value \
  182.           "^-?[string range $arg 1 end]( .*)?$"]] == -1} {
  183.         set o($arg) 1
  184.         } else {
  185.         if {[llength [set the_arg [lindex $take_value $idx]]] == 1} {
  186.             $set o($arg) [lindex $a 0]
  187.             set a [lreplace $a 0 0]
  188.         } else {
  189.             set numargs [expr {[lindex $the_arg 1] -1}]
  190.             $set o($arg) [lrange $a 0 $numargs]
  191.             set a [lreplace $a 0 $numargs]
  192.         }
  193.         }
  194.     }
  195.     }
  196. }
  197.  
  198. ## 
  199.  # -------------------------------------------------------------------------
  200.  # 
  201.  # "ensureset" --
  202.  # 
  203.  #  Ensure the given variable is set, if it is unset, set it to the given
  204.  #  value.  This works with both variables and array elements, including
  205.  #  things which contain spaces etc.
  206.  # -------------------------------------------------------------------------
  207.  ##
  208. proc ensureset {v {val ""}} {
  209.     if {[uplevel [list info exists $v]]} { return [uplevel [list set $v]] }
  210.     return [uplevel [list set $v $val]]
  211. }
  212. ## 
  213.  # -------------------------------------------------------------------------
  214.  # 
  215.  # "lunion" --
  216.  # 
  217.  #  Basic use: make sure a given list variable contains each element 
  218.  #  of 'args'
  219.  #  
  220.  #  "llunion" --
  221.  #  
  222.  #  Advanced use: make sure a given list variable and index contains
  223.  #  an element whose i'th index matches the i'th index of one of 'args'.
  224.  #  In this case we call the proc with a list {var i} as first argument.
  225.  # -------------------------------------------------------------------------
  226.  ##
  227. proc lunion {var args} {
  228.     upvar $var a
  229.     if {![info exists a]} {
  230.     set a $args
  231.     return
  232.     } else {
  233.     foreach item $args {
  234.         if {[lsearch $a $item] == -1} {
  235.         lappend a $item
  236.         }
  237.     }
  238.     }
  239. }
  240.     
  241. proc llunion {var idx args} {
  242.     upvar $var a
  243.     if {![info exists a]} {
  244.     set a $args
  245.     return
  246.     } else {
  247.     foreach item $args {
  248.         set add 1
  249.         foreach i $a {
  250.         if {[lindex $i $idx] == [lindex $item $idx]} {
  251.             set add 0
  252.             break
  253.         }
  254.         }
  255.         if {$add} {
  256.         lappend a $item
  257.         }
  258.     }
  259.     }
  260. }
  261.  
  262. proc lunique {l} {
  263.     set lout ""
  264.     foreach f $l {
  265.     if {![info exists silly($f)]} {
  266.         set silly($f) 1
  267.         lappend lout $f
  268.     }
  269.     }
  270.     return $lout
  271. }
  272.             
  273. proc lreverse {l} {
  274.     if {[llength $l] > 1} {
  275.     set first [lindex $l 0]
  276.     set l [lreverse [lrange $l 1 end]]
  277.     lappend l $first
  278.     }
  279.     return $l
  280. }
  281.  
  282. proc lcontains {l e} {
  283.     upvar $l ll
  284.     if {[info exists ll] && [lsearch -exact $ll $e] != -1} {
  285.     return 1
  286.     } else {
  287.     return 0
  288.     }
  289. }
  290.  
  291. ## 
  292.  # -------------------------------------------------------------------------
  293.  # 
  294.  # "llindex" --
  295.  # 
  296.  #  Find the first index of a given list within another list.  
  297.  # -------------------------------------------------------------------------
  298.  ##
  299. proc llindex {l e args} {
  300.     upvar $l ll
  301.     if {![info exists ll]} { return -1 }
  302.     if {![llength $args]} {
  303.     return [lsearch -exact $ll $e]
  304.     } else {
  305.     set i 0
  306.     set len [llength $args]
  307.     while {$i < [llength $ll] - $len} {
  308.         if {[lindex $ll $i] == $e} {
  309.         set range [lrange $ll [expr {$i +1}] [expr {$i + $len}]]
  310.         for {set j 0} {$j < $len} {incr j} {
  311.             if {[lindex $args $j] != [lindex $range $j]} {
  312.             break
  313.             }
  314.         }
  315.         if {$j == $len} { return $i}
  316.         }
  317.         incr i
  318.     }
  319.     return -1
  320.     }
  321. }
  322.  
  323. # Returns a modified text string if the string $text is non-null, 
  324. # and the null string otherwise.  The argument 'operation' is a 
  325. # string directing 'doSuffixText' to either "insert" or "remove" 
  326. # $suffixString to/from each line of $text.
  327. proc doSuffixText {operation suffixString text} {
  328.     if {$text == ""} {return ""}
  329.     set suff [quote::Find $suffixString]
  330.     if {$operation == "insert"} {
  331.         set str ${suffixString}\r
  332.         regsub -all \r $text $str text
  333.     } elseif {$operation == "remove"} {
  334.         set str ${suff}\r
  335.         regsub -all $str $text \r text
  336.     }
  337.     return $text
  338. }
  339.  
  340. # Returns a modified text string if the string $text is non-null, 
  341. # and the null string otherwise.  The argument 'operation' is a 
  342. # string directing 'doPrefixText' to either "insert" or "remove" 
  343. # $prefixString to/from each line of $text.  See latexEngine.tcl
  344. # for an example.
  345. proc doPrefixText {operation prefixString text} {
  346.     set pref [quote::Find $prefixString]
  347.     if {$operation == "insert"} {
  348.     set trailChar ""
  349.     set textLen [string length $text]
  350.     if {$textLen && ([string index $text [expr {$textLen-1}]] == "\r")} {
  351.         set text [string range $text 0 [expr {$textLen-2}]]
  352.         set trailChar "\r"
  353.     }
  354.     set str \r$prefixString
  355.     regsub -all \r $text $str text
  356.     return $prefixString$text$trailChar
  357.     } elseif {$operation == "remove"} {
  358.     regsub -all \r$pref $text \r text
  359.     regsub ^$pref $text "" text
  360.     return $text
  361.     }
  362. }
  363.  
  364. proc text::british {v} {
  365.     uplevel "regsub -all -nocase {(Colo)r} \[set $v\] {\\1ur} $v"
  366. }
  367.  
  368. rename getAscii {}
  369. proc getAscii {} {
  370.     set c [lookAt [getPos]]
  371.     scan $c %c decVal
  372.     set asOctal [format %o $decVal]
  373.     set asHex   [format %x $decVal]
  374.     alertnote "saw a \"$c\", $decVal -decimal,\
  375.       \\$asOctal -octal, x$asHex -hex"
  376. }
  377.  
  378. # nabbed from html mode
  379. set text::_Ascii "\001\002\003\004\005\006\007\010\011\012\013\014\015\016\017"
  380. append text::_Ascii "\020\021\022\023\024\025\026\027\030\031\032\033\034\035\036\037"
  381. append text::_Ascii " !\"#\$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ"
  382. append text::_Ascii "\[\\\]^_`abcdefghijklmnopqrstuvwxyz{|}~\177ÄÅÇÉÑÖÜáàâäãåçéèêë"
  383. append text::_Ascii "íìîïñóòôöõúùûü†°¢£§•¶ß®©™´¨≠ÆØ∞±≤≥¥µ∂∑∏π∫ªºΩæø¿¡¬√ƒ≈Δ«»… ÀÃÕŒœ–—"
  384. append text::_Ascii "“”‘’÷◊ÿŸ⁄€‹›fifl‡·‚„‰ÂÊÁËÈÍÎÏÌÓÔÒÚÛÙıˆ˜¯˘˙˚¸˝˛ˇ"
  385. proc text::Ascii {char {num 0}} {
  386.     if {$char == ""} {return 0}
  387.     global text::_Ascii
  388.     if {$num} {
  389.     if {$char > 256 || $char < 1} { beep ; message "text::Ascii called with bad argument" }
  390.     return [string index ${text::_Ascii} [expr {$char - 1}]]
  391.     } else {
  392.     return [expr {1 + [string first $char ${text::_Ascii}]}]
  393.     }
  394. }
  395.  
  396. proc text::fromPstring {str} {
  397.     set len [text::Ascii [string index $str 0]]
  398.     return [string range $str 1 $len]
  399. }
  400.  
  401. # Useful for -command flag of 'lsort'.
  402. proc sortByTail {one two} {
  403.     string compare [file tail $one] [file tail $two]
  404. }
  405.  
  406.  
  407. namespace eval is {}
  408.  
  409. proc is::Hexadecimal {str} {
  410.     return [regexp {^[0-9a-fA-F]+$} [string trim $str]]
  411. }
  412.  
  413. proc is::Numeric {str} {
  414.     return [expr {![catch {expr {$str}}]}]
  415. }
  416.  
  417. proc is::Integer {str1} {
  418.     return [regexp {^(\+|-)?[0-9]+$} [string trim $str1]]
  419. }
  420.  
  421. proc is::UnsignedInteger {str1} {
  422.     return [regexp {^[0-9]+$} [string trim $str1]]
  423. }
  424.  
  425. proc is::PositiveInteger {str1} {
  426.     if {[is::UnsignedInteger $str1]} {
  427.     return [expr {$str1 > 0}]
  428.     }
  429.     return 0
  430. }
  431.  
  432. # Takes any string and tests whether or not that string contains all 
  433. # whitespace characters.  Carriage returns are considered whitespace, 
  434. # as are spaces and tabs.  Also returns true for the null string.
  435. proc is::Whitespace {anyString} {
  436.     return [regexp "^\[ \t\r\n\]*$" $anyString]
  437. }
  438.  
  439.  
  440. ###########################################################################
  441. #  Parse a string into "word"s, which include blocks of non-space text,
  442. #  double- and single-quoted strings, and blocks of text enclosed in 
  443. #  balanced parentheses or curly brackets.
  444. #
  445. #  If a word is delimited by a quote or paren character (\", \', \(, or \{),
  446. #  then _that_ particular delimiter may be included within the word if it is 
  447. #  backslash-quoted, as above.  No other characters are special or need quoting
  448. #  with that word.  The quoted delimiters are unquoted in the list of words 
  449. #  returned.  
  450. #
  451. proc parseWords {entry} {
  452.     set slash "\\"
  453.     set qslash "\\\\"
  454.     
  455.     set words {}
  456.     set entry [string trim $entry]
  457.  
  458.     while {[string length $entry]} {
  459.         set delim [string range $entry 0 0]
  460.         set entry [string range $entry 1 end]
  461.  
  462. #        regexp $endPat   matches the end of the word
  463. #               $openPat  matches the open delimiter
  464. #               $unescPat matches escaped instances of the open/close delimiters
  465. #
  466. #        $type == "quote" means open/close delimiters are the same
  467. #              == "paren" means there's a close delimiter and nesting is possible
  468. #              == "unquoted" means the word is delimited by whitespace.
  469. #
  470.         if {$delim == {"}} {            set endPat {^([^"]*)"}
  471.                                         set unescPat {\\(")}
  472.                                         set type quote
  473.             
  474.         } elseif {$delim == {'}} {        set endPat {^([^']*)'}
  475.                                         set unescPat {\\(')}
  476.                                         set type quote
  477.             
  478.         } elseif {$delim == "\{"} {        set endPat "^(\[^\}\]*)\}"
  479.                                         set openPat "\{"
  480.                                         set unescPat "\\\\(\[\{\}\])"
  481.                                         set type paren
  482.             
  483.         } elseif {$delim == "("} {        set endPat {^([^)]*)\)}
  484.                                         set openPat {(}
  485.                                         set unescPat {\\([()])}
  486.                                         set type paren
  487.                                         
  488.         } else {                        set type unquoted
  489.         }
  490.         
  491.         if {$type == "quote"} {
  492.             set ck $qslash
  493.             set fld ""
  494.             while {$ck == $qslash} {
  495.                 set ok [regexp -indices $endPat $entry mtch sub1]
  496.                 if {$ok} {
  497.                     append fld [string range $entry [lindex $mtch 0] [lindex $mtch 1]]
  498.                     set ck $slash[string range $entry [lindex $sub1 1] [lindex $sub1 1]]
  499.                     set pos [expr {1 + [lindex $mtch 1]}]
  500.                     set entry [string range $entry $pos end]
  501.                 } else {
  502.                     error "Couldn't match $delim as field delimiter"
  503.                 }
  504.             }
  505.             set pos [expr {[string length $fld] - 2}]
  506.             set fld [string range $fld 0 $pos]
  507.             regsub -all $unescPat $fld {\1} fld
  508.            
  509.         } elseif {$type == "paren"} {
  510.         
  511.             set nopen 1
  512.             set nclose 0
  513.             set fld ""
  514.             while {$nopen - $nclose != 0} {
  515.                 set ok [regexp -indices $endPat $entry mtch sub1]
  516.                 if {$ok} {
  517.                     append fld [string range $entry [lindex $mtch 0] [lindex $mtch 1]]
  518.                     set ck $slash[string range $entry [lindex $sub1 1] [lindex $sub1 1]]
  519.                     set entry [string range $entry [expr {1 + [lindex $mtch 1]}] end]
  520.                     regsub -all $unescPat $fld {} fld1
  521.                     set nopen [llength [split $fld1 $openPat]]
  522.                     if {$ck != $qslash} { incr nclose }
  523.                 } else {
  524.                     error "Couldn't match $delim as field delimiter"
  525.                 } 
  526.             }
  527.             set pos [expr {[string length $fld] - 2}]
  528.             set fld [string range $fld 0 $pos]
  529.             regsub -all $unescPat $fld {\1} fld
  530.  
  531.         } elseif {$type == "unquoted"} {
  532.         
  533.             set entry ${delim}${entry}
  534.             set ok [regexp -indices {^([^     ]*)} $entry mtch sub1]
  535.             if {$ok} {
  536.                 set fld [string range $entry [lindex $sub1 0] [lindex $sub1 1]]
  537.                 set pos [expr {1 + [lindex $mtch 1]}]
  538.                 set entry [string range $entry $pos end]
  539.             } else {
  540.                 set fld ""
  541.                 set entry ""
  542.             }
  543.         } else {
  544.             error "parseWords: unrecognized case"
  545.         }
  546.     
  547.         lappend words $fld
  548.         set entry [string trimleft $entry]
  549.     }
  550.     return $words
  551. }
  552.  
  553.